home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
DELPHI32
/
GRIDS
/
MSTRGRID
/
MSTRLIST.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-06-17
|
15KB
|
476 lines
unit mstrlist;
(* Version 1.0, 10.6.1996, Freeware, Albrecht Mengel, mengel@stat-econ.uni-kiel.de
This is a sister of TStringList with some new sorting properties:
property KeyType:(soString,soStringCaseSensitive,soNumeric)
This is the kind, how the keys (and cells) are compared.
If you work with soNumeric, all non numbers get the same value 0.
As these zero values would flip in random order a (case insensitive) string sort
is performed after. So, first come the negatives, then the strings, and thereafter
the positives.
property KeyPos:Integer;
property KeyLen:Integer;
Here you may define, which substring of the cells is used to comparision.
(Default is KeyPos=1 & KeyLen=MaxInt)
property ScipFirst:Integer;
Here you can exclude some first entries from sorting.
(It is used by mStringGrid for excluding fixed rows/cols)
When you set sorting to true then the sorting is done with the new properties.
The default settings result in the same sorting as TStringList does.
TmStrList is a copy of TStringList found in \source\vcl\grids.pas with some additional
entries.
I had a problem with compiling TStringList.Changed and TStringList.Changing:
They call the property FUpdateCount which I could not reach:
procedure TmStrList.Changed;
begin
if {!(FUpdateCount = 0) and} Assigned(FOnChange) then FOnChange(Self);
end;
procedure TmStrList.Changing;
... the same ...
Is there anyone to fix that problem???
Software development:
Programming consumes time, and programmed components save time.
If you like my components feel free to send me some acknowledgment.
I accept post cards of your town, money or cheques (2$ up to 20$).
This is a motivation for me to continue developing for you.
If you have some ideas to improve mStrList, mStrGrid or any other component
send me a message.
The mStrList is copyright (C) 1996, by Albrecht Mengel. You may give copies to
others by copying the original, unmodified zip file. You may use this component
in your own projects free of charge as long as those projects are public domain,
freeware or shareware project.
The author of mStrList (A. Mengel) makes no warranty of any kind,
expressed or implied, including without limitation any warranties of merchantability
and/or fitness for a particular purpose. In no event will the author be liable to you
for any additional damages, including any lost profits, lost savings, or other
incidental or consequential damages arising from the use of, or inability to use,
this software and its accompanying documentation, even if the author has been advised
of the possibility of such damages.
Albrecht Mengel, University of Kiel, Germany
Institute for Statistics & Economics
Olshausenstrasse 40-60,
D-24098 Kiel
Tel. +49-431-880-2424
Fax. +49-431-880-2673
Email: mengel@stat-econ.uni-kiel.de
http://www.stat-econ.uni-kiel.de/pers/mengel.htm
*)
{$R-}
interface
uses classes;
type
TMSortType = (soString,soStringCaseSensitive,soNumeric);
TmStrList = class(TStrings)
private
fKeyType:TMSortType;
fKeyLen:Integer;
fKeyPos:Integer;
fScipFirst:Integer;
FList: PStringItemList;
FCount: Integer;
FCapacity: Integer;
FSorted: Boolean;
FDuplicates: TDuplicates;
FOnChange: TNotifyEvent;
FOnChanging: TNotifyEvent;
procedure SetKeyType(value:TMSortType);
procedure SetKeyLen(value:Integer);
procedure SetKeyPos(value:Integer);
procedure ExchangeItems(Index1, Index2: Integer);
procedure Grow;
procedure QuickSort(L, R: Integer);
procedure InsertItem(Index: Integer; const S: string);
procedure SetCapacity(NewCapacity: Integer);
procedure SetSorted(Value: Boolean);
procedure Sort_Alpha;
protected
procedure Changed; virtual;
procedure Changing; virtual;
function Get(Index: Integer): string; override;
function GetCount: Integer; override;
function GetObject(Index: Integer): TObject; override;
procedure Put(Index: Integer; const S: string); override;
procedure PutObject(Index: Integer; AObject: TObject); override;
procedure SetUpdateState(Updating: Boolean); override;
public
constructor create;
destructor Destroy; override;
function Add(const S: string): Integer; override;
procedure Clear; override;
procedure Delete(Index: Integer); override;
procedure Exchange(Index1, Index2: Integer); override;
function Find(const S: string; var Index: Integer): Boolean; virtual;
function IndexOf(const S: string): Integer; override;
procedure Insert(Index: Integer; const S: string); override;
procedure Sort; virtual;
property Duplicates: TDuplicates read FDuplicates write FDuplicates;
property Sorted: Boolean read FSorted write SetSorted;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
property KeyType:TMSortType read fKeyType write SetKeyType;
property KeyLen:Integer read fKeyLen write SetKeyLen;
property KeyPos:Integer read fKeyPos write SetKeyPos;
property ScipFirst:Integer read fScipFirst write fScipFirst;
published
end;
implementation
uses SysUtils, Consts;
FUNCTION rVAL(CONST von:String):Real;
{Reads a real value out of the string without an error message.
Returns 0 if no numeric value}
VAR bis,err:Integer; nach:Real;
BEGIN VAL(von,nach,bis);
IF bis>0 THEN VAL(copy(von,1,bis-1),nach,err);
rVAL:=nach
END;{rVAL}
constructor TmStrList.create;
begin fKeyPos:=1;
fKeyLen:=MaxInt;
end;
procedure TmStrList.SetKeyType(value:TMSortType);
begin if value<>fKeyType then
begin fKeyType:=value;
if FSorted and (fCount>1) then
begin Changing;
QuickSort(fScipFirst,fCount-1);
if fKeyType=soNumeric then Sort_Alpha;
Changed;
end end end;
procedure TmStrList.SetKeyLen(value:Integer);
begin if value<>fKeyLen then
begin if value<1 then value:=1;
{showmessage('Keylen: '+inttostr(fKeylen)+' -> '+inttostr(value));}
fKeyLen:=value;
if FSorted and (fCount>1) then
begin Changing;
QuickSort(fScipFirst,fCount-1);
if fKeyType=soNumeric then Sort_Alpha;
Changed;
end end end;
procedure TmStrList.SetKeyPos(value:Integer);
begin if value<>fKeyPos then
begin if value<1 then value:=1;
{showmessage('KeyPos: '+inttostr(fKeypos)+' -> '+inttostr(value));}
fKeyPos:=value;
if FSorted and (fCount>1) then
begin Changing;
QuickSort(fScipFirst,fCount-1);
if fKeyType=soNumeric then Sort_Alpha;
Changed;
end end end;
procedure TmStrList.QuickSort(L, R: Integer);
var
I, J: Integer;
P: string; Pr:Real;
begin
case fKeyType of
soString: repeat I := L; J := R;
P := copy(FList^[(L + R) shr 1].FString,fKeyPos,fKeyLen);
repeat while AnsiCompareText(copy(FList^[I].FString,fKeyPos,fKeyLen),P)<0 do Inc(I);
while AnsiCompareText(copy(FList^[J].FString,fKeyPos,fKeyLen),P)>0 do Dec(J);
if I <= J then begin
ExchangeItems(I, J);
Inc(I); Dec(J);
end;
until I > J;
if L < J then QuickSort(L, J);
L := I;
until I >= R;
soStringCaseSensitive:
repeat I := L; J := R;
P := copy(FList^[(L + R) shr 1].FString,fKeyPos,fKeyLen);
repeat while copy(FList^[I].FString,fKeyPos,fKeyLen)<P do Inc(I);
while copy(FList^[J].FString,fKeyPos,fKeyLen)>P do Dec(J);
if I <= J then begin
ExchangeItems(I, J);
Inc(I); Dec(J);
end;
until I > J;
if L < J then QuickSort(L, J);
L := I;
until I >= R;
soNumeric: repeat I := L; J := R;
Pr:= Rval(copy(FList^[(L + R) shr 1].FString,fKeyPos,fKeyLen));
repeat while Rval(copy(FList^[I].FString,fKeyPos,fKeyLen))<Pr do Inc(I);
while Rval(copy(FList^[J].FString,fKeyPos,fKeyLen))>Pr do Dec(J);
if I <= J then begin
ExchangeItems(I, J);
Inc(I); Dec(J);
end;
until I > J;
if L < J then QuickSort(L, J);
L := I;
until I >= R;
end
end;
procedure ListError(Ident: Integer);
begin
raise EListError.CreateRes(Ident);
end;
procedure ListIndexError;
begin
ListError(SListIndexError);
end;
destructor TmStrList.Destroy;
begin
FOnChange := nil;
FOnChanging := nil;
if FCount <> 0 then Finalize(FList^[0], FCount);
FCount := 0;
SetCapacity(0);
end;
function TmStrList.Add(const S: string): Integer;
begin
if not Sorted then
Result := FCount
else
if Find(S, Result) then
case Duplicates of
dupIgnore: Exit;
dupError: ListError(SDuplicateString);
end;
InsertItem(Result, S);
end;
procedure TmStrList.Changed;
begin
if {!(FUpdateCount = 0) and} Assigned(FOnChange) then FOnChange(Self);
end;
procedure TmStrList.Changing;
begin
if {!(FUpdateCount = 0) and} Assigned(FOnChanging) then FOnChanging(Self);
end;
procedure TmStrList.Clear;
begin
if FCount <> 0 then
begin
Changing;
Finalize(FList^[0], FCount);
FCount := 0;
SetCapacity(0);
Changed;
end;
end;
procedure TmStrList.Delete(Index: Integer);
begin
if (Index < 0) or (Index >= FCount) then ListIndexError;
Changing;
Finalize(FList^[Index]);
Dec(FCount);
if Index < FCount then
System.Move(FList^[Index + 1], FList^[Index],
(FCount - Index) * SizeOf(TStringItem));
Changed;
end;
procedure TmStrList.Exchange(Index1, Index2: Integer);
begin
if (Index1 < 0) or (Index1 >= FCount) or
(Index2 < 0) or (Index2 >= FCount) then ListIndexError;
Changing;
ExchangeItems(Index1, Index2);
Changed;
end;
procedure TmStrList.ExchangeItems(Index1, Index2: Integer);
var
Temp: Integer;
Item1, Item2: PStringItem;
begin
Item1 := @FList^[Index1];
Item2 := @FList^[Index2];
Temp := Integer(Item1^.FString);
Integer(Item1^.FString) := Integer(Item2^.FString);
Integer(Item2^.FString) := Temp;
Temp := Integer(Item1^.FObject);
Integer(Item1^.FObject) := Integer(Item2^.FObject);
Integer(Item2^.FObject) := Temp;
end;
function TmStrList.Find(const S: string; var Index: Integer): Boolean;
var
L, H, I, C: Integer;
begin
Result := False;
L := 0;
H := FCount - 1;
while L <= H do
begin
I := (L + H) shr 1;
C := AnsiCompareText(FList^[I].FString, S);
if C < 0 then L := I + 1 else
begin
H := I - 1;
if C = 0 then
begin
Result := True;
if Duplicates <> dupAccept then L := I;
end;
end;
end;
Index := L;
end;
function TmStrList.Get(Index: Integer): string;
begin
if (Index < 0) or (Index >= FCount) then ListIndexError;
Result := FList^[Index].FString;
end;
function TmStrList.GetCount: Integer;
begin
Result := FCount;
end;
function TmStrList.GetObject(Index: Integer): TObject;
begin
if (Index < 0) or (Index >= FCount) then ListIndexError;
Result := FList^[Index].FObject;
end;
procedure TmStrList.Grow;
var
Delta: Integer;
begin
if FCapacity > 8 then Delta := 16 else
if FCapacity > 4 then Delta := 8 else
Delta := 4;
SetCapacity(FCapacity + Delta);
end;
function TmStrList.IndexOf(const S: string): Integer;
begin
if not Sorted then Result := inherited IndexOf(S) else
if not Find(S, Result) then Result := -1;
end;
procedure TmStrList.Insert(Index: Integer; const S: string);
begin
if Sorted then ListError(SSortedListError);
if (Index < 0) or (Index > FCount) then ListIndexError;
InsertItem(Index, S);
end;
procedure TmStrList.InsertItem(Index: Integer; const S: string);
begin
Changing;
if FCount = FCapacity then Grow;
if Index < FCount then
System.Move(FList^[Index], FList^[Index + 1],
(FCount - Index) * SizeOf(TStringItem));
with FList^[Index] do
begin
Pointer(FString) := nil;
FObject := nil;
FString := S;
end;
Inc(FCount);
Changed;
end;
procedure TmStrList.Put(Index: Integer; const S: string);
begin
if Sorted then ListError(SSortedListError);
if (Index < 0) or (Index >= FCount) then ListIndexError;
Changing;
FList^[Index].FString := S;
Changed;
end;
procedure TmStrList.PutObject(Index: Integer; AObject: TObject);
begin
if (Index < 0) or (Index >= FCount) then ListIndexError;
Changing;
FList^[Index].FObject := AObject;
Changed;
end;
procedure TmStrList.SetCapacity(NewCapacity: Integer);
begin
ReallocMem(FList, NewCapacity * SizeOf(TStringItem));
FCapacity := NewCapacity;
end;
procedure TmStrList.SetSorted(Value: Boolean);
begin
if FSorted <> Value then
begin
if Value then Sort;
FSorted := Value;
end;
end;
procedure TmStrList.SetUpdateState(Updating: Boolean);
begin
if Updating then Changing else Changed;
end;
procedure TmStrList.Sort;
begin
if not Sorted and (FCount > 1) then
begin
Changing;
QuickSort(fScipFirst, FCount - 1);
if fKeyType=soNumeric then Sort_Alpha;
Changed;
end;
end;
procedure TmStrList.Sort_Alpha;
var anfang,ende:integer; found:boolean;
begin {soNumeric : die Alpha-EintrΣge nachsortieren}
anfang:=fScipFirst;
found:=false;
while anfang<fCount do
if rval(copy(FList^[anfang].FString,fKeyPos,fKeyLen))<>0
then inc(anfang)
else begin found:=true;
break
end;
if not found then exit;
ende:=anfang+1;
while ende<fCount do
if rval(copy(FList^[ende].FString,fKeyPos,fKeyLen))=0
then inc(ende)
else break;
if anfang<ende-1 then
begin fKeyType:=soString;
QuickSort(anfang,ende-1);
fKeyType:=soNumeric
end end;
end.